home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1999 January / PC Plus Super CD No55a (PCP-147A-1-99) (Disc 1) (1998).iso / linux / developers / visualtcl / windows / vtcl / lib / tabpanel.tcl < prev    next >
Encoding:
Text File  |  1997-04-22  |  3.7 KB  |  119 lines
  1. ##############################################################################
  2. # $Id: tabpanel.tcl,v 1.3 1997/04/23 05:45:19 stewart Exp $
  3. #
  4. # tabpanel.tcl - procedures to implement a tabpanel widget
  5. #
  6. # Copyright (C) 1996-1997 Stewart Allen
  7. #
  8. # This program is free software; you can redistribute it and/or
  9. # modify it under the terms of the GNU General Public License
  10. # as published by the Free Software Foundation; either version 2
  11. # of the License, or (at your option) any later version.
  12. #
  13. # This program is distributed in the hope that it will be useful,
  14. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. # GNU General Public License for more details.
  17. #
  18. # You should have received a copy of the GNU General Public License
  19. # along with this program; if not, write to the Free Software
  20. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ##############################################################################
  23. #
  24.  
  25. proc vTcl:tabpanel {args} {
  26.     global vTcl
  27.     set widget [lindex $args 0]
  28.     set cmd [lindex $args 1]
  29.     set name [lindex $args 2]
  30.  
  31.     if {[llength $args] == 1} {
  32.         frame $widget
  33.         frame $widget.l
  34.         canvas $widget.c \
  35.             -xscrollcommand "$widget.sh set" -yscrollcommand "$widget.sv set"
  36.         scrollbar $widget.sh -orient horiz -command "$widget.c xview"
  37.         scrollbar $widget.sv -orient vert -command "$widget.c yview"
  38.         grid $widget.l -sticky news -columnspan 2
  39.         grid $widget.c $widget.sv -sticky news
  40.         grid $widget.sh -sticky news
  41.         grid columnconf $widget 0 -weight 1
  42.         grid rowconf $widget 1 -weight 1
  43.         update idletasks
  44.         bind $widget <Configure> "vTcl:tabpanel_update $widget"
  45.         set vTcl(tab,$widget,current) ""
  46.         return $widget
  47.     }
  48.  
  49.     switch $cmd {
  50.         addtab {
  51.             set name [vTcl:rename $name]
  52.             label $widget.l.$name -text $name -bd 1 -relief raised
  53.             bind $widget.l.$name <ButtonPress> "
  54.                 vTcl:tabpanel_raise $widget $name
  55.             "
  56.             pack $widget.l.$name -side left -expand 1 -fill both
  57.             frame $widget.c.$name
  58.             bind $widget.c.$name <Configure> "
  59.                 vTcl:tabpanel_update $widget
  60.             "
  61.             $widget.c create window 0 0 -window $widget.c.$name -tag $name -anchor nw
  62.             vTcl:tabpanel_raise $widget $name
  63.             return $widget.c.$name
  64.         }
  65.     }
  66. }
  67.  
  68. proc vTcl:tabpanel_raise {widget name} {
  69.     global vTcl
  70.     set c $vTcl(tab,$widget,current)
  71.     if {$c != ""} {
  72.         $widget.c coords $vTcl(tab,$widget,current) -1000 -1000
  73.         $widget.l.$vTcl(tab,$widget,current) conf -relief raised
  74.     }
  75.     $widget.c coords $name 0 0
  76.     $widget.l.$name conf -relief sunken
  77.     set vTcl(tab,$widget,current) $name
  78. }
  79.  
  80. proc vTcl:tabpanel_update {widget} {
  81.     global vTcl
  82.     update idletasks
  83.     set name $vTcl(tab,$widget,current)
  84.     set cw [winfo width $widget.c]
  85.     set ch [winfo height $widget.c]
  86.     set fw [winfo width $widget.c.$name]
  87.     set fh [winfo height $widget.c.$name]
  88.     if {$cw < $fw} {
  89.         grid $widget.sh -sticky news -column 0 -row 2
  90.     } else {
  91.         grid forget $widget.sh
  92.     }
  93.     if {$ch < $fh} {
  94.         grid $widget.sv -sticky news -column 1 -row 1
  95.     } else {
  96.         grid forget $widget.sv
  97.     }
  98.     $widget.c conf -scrollregion "0 0 $fw $fh"
  99. }
  100.  
  101. proc vTcl:tabtest {} {
  102.     source misc.tcl
  103.     vTcl:tabpanel .x
  104.     set a [vTcl:tabpanel .x addtab "test"]
  105.     text $a.t
  106.     pack $a.t
  107.     set b [vTcl:tabpanel .x addtab "fred"]
  108.     label $b.l -text "this is a label"
  109.     button $b.b -text "this is a button" -command "
  110.         text $b.t
  111.         pack $b.t
  112.     "
  113.     pack $b.l $b.b
  114.  
  115.     pack .x -expand 1 -fill both
  116. }
  117.  
  118. vTcl:tabtest
  119.